home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
PD Collection CD 1
/
PD Collection CD 1.iso
/
programer2
/
pari2
/
pari
/
c
/
init
< prev
next >
Wrap
Text File
|
1991-11-28
|
9KB
|
331 lines
/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/
/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/
/* */
/* */
/* PROGRAMME D'INITIALISATION DU SYSTEME */
/* */
/* ET TRAITEMENT DES ERREURS */
/* */
/* copyright Babe Cool */
/* */
/* */
/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/
/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/
#include "genpari.h"
/* Variables statiques communes : */
unsigned long top,bot,avma;
long prec=5, precdl=16, defaultpadicprecision=16;
long tglobal,paribuffsize=30000,pariecho=0;
jmp_buf environnement;
FILE *outfile = stdout;
FILE *logfile = NULL;
FILE *infile = stdin;
long nvar = 0;
GEN gnil,gzero,gun,gdeux,ghalf,polvar,gi,RAVYZARC;
GEN gpi=(GEN)0;
GEN geuler=(GEN)0;
GEN bernzone=(GEN)0;
entree **varentries, *hashtable[TBLSZ];
GEN *blocliste, *polun, *polx, *g;
long *ordvar,varchanged=0;
long nextbloc = 0;
long glbfmt[]={'g',0,28};
byteptr diffptr;
long lontyp[30]={0,0x10000,0x10000,1,1,1,1,2,1,1,2,2,0,1,1,1,1,1,1,1};
long lontyp2[30]={0,0x10000,0x10000,2,1,1,1,3,2,2,2,2,0,1,1,1,1,1,1,1};
/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/
/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/
/* */
/* INITIALISATION DU SYSTEME */
/* */
/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/
/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/
void catchinterrupt()
{
signal(SIGINT,catchinterrupt);
err(interrupter);
}
void init(parisize,maxprime)
long parisize,maxprime;
{
long v, n;
char *p;
GEN p1;
if (setjmp(environnement))
{
fprintf(stderr, "\n ### Error in the PARI system. End of the program.\n");
exit(1);
}
signal(SIGINT,catchinterrupt);
if (!(diffptr=initprimes(maxprime))) err(memer);
if (!(bot=(long)malloc(parisize))) err(memer);
top=avma=bot+parisize;
if (!(varentries=(entree **)malloc(4*MAXVAR))) err(memer);
if (!(blocliste=(GEN *)malloc(4*MAXBLOC))) err(memer);
if (!(ordvar=(long *)malloc(4*MAXVAR))) err(memer);
if (!(polun=(GEN *)malloc(1024))) err(memer);
if (!(polx=(GEN *)malloc(1024))) err(memer);
if (!(g=(GEN *)malloc(4*STACKSIZE))) err(memer);
for(n = 0; n < TBLSZ; n++) hashtable[n] = NULL;
for(v = 0; v < NUMFUNC; v++)
{
for(n = 0, p = fonctions[v].name; *p; p++) n = n << 1 ^ *p;
if (n < 0) n = -n; n %= TBLSZ;
fonctions[v].next = hashtable[n];
hashtable[n] = fonctions + v;
}
gnil = cgeti(2);gnil[1]=2; setpere(gnil,255);
gzero = cgeti(2);gzero[1]=2; setpere(gzero, 255);
gun = stoi(1); setpere(gun, 255);
gdeux = stoi(2); setpere(gdeux, 255);
ghalf = cgetg(3,4);ghalf[1]=un;ghalf[2]=deux; setpere(ghalf, 255);
gi = cgetg(3,6); gi[1] = zero; gi[2] = un; setpere(gi, 255);
p1=cgetg(4,10);p1[1]=0x1ff0004;p1[2]=zero;p1[3]=un;polx[255]=p1;
p1=cgetg(3,10);p1[1]=0x1ff0003;p1[2]=un;polun[255]=p1;
for(v=0; v < MAXVAR; v++) ordvar[v] = v;
polvar = cgetg(MAXVAR + 1,17); setlg(polvar,1); setpere(polvar, 255);
for(v=1;v<=MAXVAR;v++) polvar[v]=0x11ff0001;
for(v = 0; v < MAXBLOC; v++) blocliste[v] = (GEN)0;
for(v = 0; v < STACKSIZE; v++) g[v] = gzero;
lisseq("x");
}
GEN geni()
{
return gi;
}
long marklist()
{
long i;
GEN x, *p = blocliste;
for (i = 0; i < MAXBLOC; i++)
if(x = blocliste[i])
{
x[-2] = (long)p;
*p++ = x;
}
for (nextbloc = i = p - blocliste; i < MAXBLOC; i++)
blocliste[i] = 0;
return nextbloc;
}
GEN newbloc(n)
long n;
{
long i, *x;
for(i = nextbloc; i < MAXBLOC; i++) if (!blocliste[i]) break;
if (i == MAXBLOC)
{
for (i = 0; i < nextbloc; i++) if (!blocliste[i]) break;
if (i == nextbloc) err(newblocer1);
}
x = (long *)malloc((n << 2) + 8);
if (!x) err(memer);
x += 2;
x[-2] = (long)(blocliste + i);
x[-1] = 0;
blocliste[i] = x;
nextbloc = i + 1;
return x;
}
void killbloc(x)
GEN x;
{
if (!x || isonstack(x)) return;
*(long *)x[-2] = 0;
free(x-2);
}
void newvalue(ep, val)
entree *ep;
GEN val;
{
GEN y = gclone(val);
y[-1] = (long) ep->value;
ep->value = (void *)y;
}
void changevalue(ep, val)
entree *ep;
GEN val;
{
GEN y = gclone(val);
GEN x = (GEN)ep->value;
ep->value = (void *)y;
if ((long)x - (long)ep == sizeof(entree))
{
y[-1] = (long)x;
return;
}
y[-1] = x[-1];
killbloc(x);
}
void killvalue(ep)
entree *ep;
{
GEN x = (GEN)ep->value;
if ((long)x - (long)ep == sizeof(entree)) return;
ep->value = (void *)x[-1];
killbloc(x);
}
void install(f, name, valence)
GEN (*f)();
char *name;
int valence;
{
int n;
entree *ep;
char *p;
if ((valence < 0) || (valence > 3)) err(valencer1);
for(n = 0, p = name; *p; p++) n = n << 1 ^ *p;
if (n < 0) n = -n; n %= TBLSZ;
for(ep = hashtable[n]; ep; ep = ep->next)
if (!strcmp(name, ep->name)) err(nomer);
ep = (entree *)malloc(sizeof(entree) + strlen(name) + 1);
ep->name = (char *)ep + sizeof(entree); strcpy(ep->name, name);
ep->value = (void *)f;
ep->valence = valence;
ep->next = hashtable[n];
hashtable[n] = ep;
}
void preserve(av, nb)
long av, nb;
{
GEN q,**s;
long i,tetpil=avma;
for(s=(GEN**)&nb,i=1; i<nb; i++) {s++; **s = gcopy(**s);}
q=cgetg(nb+1,17);
for(s=(GEN**)&nb,i=1; i<nb; i++) q[i]=(long)**++s;
q=gerepile(av, tetpil,q);
for(s=(GEN**)&nb,i=1; i<nb; i++) **++s=(GEN)q[i];
avma+=(nb+1)*sizeof(long);
}
/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/
/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/
/* */
/* TRAITEMENT DES ERREURS */
/* */
/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/
/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/
void err(numerr,ch,noninv)
long numerr;
char *ch;
GEN noninv;
{
char c;
FILE *temp;
fprintf(stderr, "\n *** %s",errmessage[numerr]);
switch (numerr)
{
case matcher1:
c = *ch++;
fprintf(stderr, "'%c'\n *** instead of: '%s'", c, ch); break;
case impl: fprintf(stderr, " %s is not yet implemented.",ch); break;
case talker: fprintf(stderr, "%s.",ch); break;
case invmoder: temp=outfile;outfile=stderr;fprintf(stderr,": ");
output(noninv);outfile=temp;break;
case varer1:
case unknowner1:
case caracer1: fprintf(stderr, "'%s'",ch);
}
putc('\n', stderr);
longjmp(environnement, numerr);
}
void recover(listloc)
long listloc;
{
long i, m, n;
GEN x;
entree *ep, *ep2;
for (n = 0; n < TBLSZ; n++)
for (ep = hashtable[n]; ep;)
if (ep->valence >= 100)
{
x = (GEN)ep->value;
if ((long)x - (long)ep == sizeof(entree))
{
if (ep->valence == 200) ep = ep->next;
else
if (ep == hashtable[n])
{
hashtable[n] = ep->next;
free(ep);
ep = hashtable[n];
}
else
{
for(ep2 = hashtable[n]; ep2->next != ep; ep2 = ep2->next);
ep2->next = ep->next;
free(ep); ep = ep2->next;
}
continue;
}
m = (long *)x[-2] - (long *)blocliste;
if ((m < listloc) || (m >= MAXBLOC)) ep=ep->next;
else killvalue(ep);
}
else ep = ep->next;
for (i = listloc; i < MAXBLOC; i++)
if ((x = blocliste[i]) && (x != gpi) && (x != geuler))
killbloc(x);
}
void allocatemoremem()
{
long av,declg,declg2,tl,parisize,v;
GEN ll,pp,l1,l2,l3;
unsigned long topold,avmaold,botold;
err(errpile); /* Peut-etre pourra-t-on utiliser ce qui suit plus tard */
avmaold=avma;topold=top;botold=bot;parisize=(topold-botold)<<1;
if (!(bot=(long)malloc(parisize))) err(errpile);
fprintf(stderr, " *** Warning: doubling the stack size; new stack = %d\n",parisize);
top=avma=bot+parisize;
declg=(long)top-(long)topold;declg2=declg>>2;
for(ll=(GEN)top,pp=(GEN)topold;pp>(GEN)avmaold;) *--ll= *--pp;
av=(long)ll;
while(ll<(GEN)top)
{
l2=ll+lontyp[tl=typ(ll)];
if(tl==10) {l3=ll+lgef(ll);ll+=lg(ll);if(l3>ll) l3=l2;}
else {ll+=lg(ll);l3=ll;}
for(;l2<l3;l2++)
{
l1=(GEN)(*l2);
if((l1<(GEN)topold)&&(l1>=(GEN)avmaold)) *l2+=declg;
}
}
gnil+=declg2;gzero+=declg2;gun+=declg2;gdeux+=declg2;ghalf+=declg2;
gi+=declg2;polx[255]+=declg2;polun[255]+=declg2;polvar+=declg2;
for(v=0;v<=tglobal;v++) if((g[v]<(GEN)topold)&&(g[v]>=(GEN)avmaold)) g[v]+=declg2;
free((void *)botold);avma=av;
}